;;; file: parseltongue.lisp
;;;
;;; Copyright (c) 2010 Steffen Schulz (pepe@virtuallysecure.org)
;;; Copyright (c) 2007-2009 Cyrus Harmon (ch-lisp@bobobeach.com)
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

(in-package :parseltongue)

(defstruct blog
  "Blog instance configuration"
  (short-name "MyBlog")     ; An abbreviated name for this blog.
  (title "MyTitle")         ; Title of this blog
  (subtitle "MySubtitle")   ; Subtitle of this blog
  (banner "")               ; String to include as header
  (footer "")               ; String to include as footer
  (email-uri "mailto:x@y.z"); The email address of the owner of this blog.
  (logo-img-uri "")         ; URI to a logo for this blog
  (feed-img-uri "")         ; URI to a rss/feed icon
  (page-css-uri nil)        ; Assoc list of name/URI pairs defining CSS styles for this blog
  (root-uri "/blog/")       ; The root URL for this blog  (w/o final '/', browser will not automatically send
                            ; http-auth data to main page so the authorized links will be missing there)
  (blog-links "")           ; List of html strings to embed in "Links" navi box (typically links..)
  (realm "blog")        ; The authentication realm of this blog.
  (user-db nil)             ; A list of (username . hexdump(md5sum(passwd))) pairs (assoc list)
  (use-ssl-p t)             ; If non-nil, use https pages for authorized blog pages.
  (ssl-port 443)            ; If use-ssl-p is true, this the ssl port to use
  (buttons nil)             ; List of strings that will be embedded into the navi-box "Links"
  (tag-stats nil)           ; A hash table used for keeping statistics of the entry's tags
  (entries nil)             ; List of all blog entries
  (entry-storage-path nil)  ; Path that points to a file where to store/restore blog entries
  (tag-stats-file-path nil); Path that points to a file used as tag-stats cache
  (new-entry-uri "new")    ; create a new blog entry
  (edit-entry-uri "edit")  ; edit an existing blog entry
  (delete-entry-uri "delete"); delete a blog entry
  (display-entry-uri "display") ; display single entry
  (archive-uri "archive")  ; Browse entries by tags
  (feed-uri "rss")         ; RSS feed
  (login-uri "login")      ; Dummy page that redirects to SSL and requires authentication
  (logout-uri "logout")    ; Dummy page that redirects to plain HTTP
  (num-limit 10))          ; How many entries to show on main page and RSS feed


(defstruct blog-entry
  "Structure of a blog entry"
  tags
  user
  number
  title
  time
  revised-time
  contents
  trackbacks)

(defparameter *entries-file-lock* (bt:make-lock "entries-file-lock"))
(defparameter *entries-lock* (bt:make-lock "entries-lock"))
(defparameter *tag-stats-file-lock* (bt:make-lock "tag-stats-file-lock"))
(defparameter *tag-stats-lock* (bt:make-lock "tag-stats-lock"))


(defun get-next-entry-number (blog)
  (let ((numbers (mapcar #'blog-entry-number (blog-entries blog))))
    (if numbers
      (1+ (reduce #'max numbers))
      0)))

(defun store-blog-tag-stats (blog)
  (let ((path (blog-tag-stats-file-path blog)))
    (ensure-directories-exist path)
    (bt:with-lock-held (*tag-stats-file-lock*)
                       (cl-store:store (blog-tag-stats blog) path))))

(defun generate-blog-tag-stats (blog)
  "Re-generate tag stats from tag entries"
  (dolist (entry (blog-entries blog))
    (add-blog-tag-stats (blog-tag-stats blog) (blog-entry-tags entry))))

(defun read-blog-tag-stats (blog &key (path (blog-tag-stats-file-path blog)))
  (if (and path (probe-file path))
    (bt:with-lock-held (*tag-stats-file-lock*)
                       (setf (blog-tag-stats blog) (cl-store:restore path)))
    (generate-blog-tag-stats blog)))

(defun add-blog-tag-stats (tag-stats tags)
  (bt::with-lock-held (*tag-stats-lock*)
                      (dolist (tag tags)
                        (if (nth-value 1 (gethash tag tag-stats))
                          (incf (gethash tag tag-stats))
                          (setf (gethash tag tag-stats) 1)))))

(defun rem-blog-tag-stats (tag-stats tags)
  (bt::with-lock-held (*tag-stats-lock*)
                      (dolist (tag tags)
                        (ignore-errors ; TODO: need to signal incoherent tags-cache
                          (let ((count (gethash tag tag-stats)))
                            (if (> count 1)
                              (incf (gethash tag tag-stats) -1)
                              (remhash tag tag-stats)))))))

(defun store-blog-entries (blog path)
  (ensure-directories-exist path)
  (bt:with-lock-held (*entries-file-lock*)
                     (cl-store:store (blog-entries blog) path)))

(defun read-blog-entries (blog &key (path (blog-entry-storage-path blog)))
  (when (and path
             (probe-file path))
    (bt:with-lock-held (*entries-file-lock*)
                       (setf (blog-entries blog)
                             (cl-store:restore path)))))

(defun create-blog-entry (blog tags title contents user
                               &key
                               (number (get-next-entry-number blog))
                               (time (get-universal-time)))
  (let ((entry (make-blog-entry
                 :tags tags
                 :user user
                 :number number
                 :title title
                 :time time
                 :revised-time time
                 :contents contents)))
    (bt::with-lock-held (*entries-lock*)
                        (setf (blog-entries blog)
                              (cons entry (blog-entries blog)))
                        (let ((path (blog-entry-storage-path blog)))
                          (when path (store-blog-entries blog path))))
    (add-blog-tag-stats (blog-tag-stats blog) tags)
    (store-blog-tag-stats blog)
    entry))

(defun delete-blog-entry (blog number)
  (bt:with-lock-held (*entries-lock*)
                     (when (find number (blog-entries blog) :key #'blog-entry-number)
                       (setf (blog-entries blog)
                             (delete number (blog-entries blog) :key #'blog-entry-number))
                       (let ((path (blog-entry-storage-path blog)))
                         (when path (store-blog-entries blog path)))
                       t)))

(defun get-entry (number blog)
  (bt:with-lock-held (*entries-lock*)
                     (find number (blog-entries blog) :key 'blog-entry-number)))

(defun get-blog-entries (blog &key tag)
  ;; TODO: do we need a lock here for r/o access?
  (bt:with-lock-held (*entries-lock*)
                     (cond ((null tag)
                            (copy-seq (blog-entries blog)))
                           ((atom tag)
                            (remove-if-not (lambda (x)
                                             (member tag (blog-entry-tags x) :test 'equal ))
                                           (blog-entries blog))))))
;;; TODO: filter by multiple tags 
;          ((listp tag)
;           (remove-if-not (lambda (x)
;                            (member (blog-entry-tags x)
;                                    tag
;                                    :test 'equal))
;                          (blog-entries blog))))))
;
; tag=tag1+tag2 // AND
; tag=tag1-tag2 // AND NOT
; tag=tag1*tag2 // OR
;
; order? non-associative, but process in-order
; tag=tag1*tag2-tag3 != tag1-tag3*tag2
; 
; UI: viewing tag1
;  (+) in nav: add tag2 (OR); in main: reduce view (AND)
;  (-) in nav/main: ignore this tag (AND NOT)
;  
(defun sorted-blog-entries (blog &key tag)
  (sort (apply #'get-blog-entries blog
               (when tag
                 `(:tag ,tag)))
        #'>
        :key #'blog-entry-time))


